home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / DDJ0992.ARJ / CLISP.C < prev    next >
Text File  |  1992-07-10  |  19KB  |  389 lines
  1. /*  File C-LISP.C   List of C-LISP functions.  
  2. Modified by Douglas Chubb, 1991-92.  */
  3.  
  4. /** Lisp-Style Library for C (Main File of User Functions)  **/
  5. /* Include Files */
  6. #include <stdlib.h>
  7. #include <string.h>
  8. #include <stdio.h>
  9. #include <stdarg.h>
  10. #include "lisp-header.h"
  11. #include "int-lisp-syms.h"
  12.  
  13. /**  Functions  **/
  14. /* error -- write string (args like 'printf') to 'stdout' and exit */
  15. void error (char *fstr, ...)
  16.     {
  17.         va_list ap;
  18.         va_start (ap, fstr);
  19.         fprintf(stderr, "error: ");
  20.         vfprintf (stderr, fstr, ap);
  21.         fprintf (stderr, "\n");
  22.         va_end (ap);
  23.         exit (1);
  24.             }
  25. /***********************************************************/    
  26. /** LISP List Constructors: CONS, LAST_PUT, LIST & APPEND **/
  27. /* FIRST_PUT -- add an Object to the front of a list (LISP "CONS") */
  28. Object first_put (Object item, Object list)
  29.     {
  30.         Object new_list;
  31.         new_list = (Object) safe_malloc (sizeof (Object_Type) + sizeof (Pair));
  32.         type (new_list) = PAIR;
  33.         pair (new_list) -> car = item;
  34.         pair (new_list) -> cdr = list;
  35.         return (new_list);
  36.     }
  37.     /* LAST_PUT -- add an Object to the end of a list (Destructive!) */
  38.     Object last_put (Object item, Object list)
  39.     {
  40.         Object old_list, new_list;
  41.         new_list = first_put (item, NULL);
  42.         if (list == NULL)
  43.              return (new_list);
  44.         else
  45.         {
  46.             old_list = list;
  47.             while (but_first (list) != NULL)
  48.                 list = but_first (list);
  49.             pair (list) -> cdr = new_list;
  50.             return (old_list);
  51.         }
  52.      }
  53. /* LAST -- return the list of last Object in list 'lst'     */
  54. Object last (Object lst)
  55.   {
  56.     Object foo;
  57.     if(!is_list(lst))
  58.        error("\nlast: arg not a list");
  59.       if(lst == NULL)
  60.          return(NULL);
  61.       while(lst != NULL)
  62.         {
  63.           foo = first(lst);
  64.           lst = but_first(lst);
  65.         }
  66.        return(list(foo, T_EOF));
  67.   }
  68. /* LIST -- return a new list of given arguments (last arg must be T_EOF) */
  69. Object list (Object item, ...)
  70.   {
  71.           va_list ap;
  72.           Object result;
  73.           result = NULL;
  74.           va_start (ap, item);
  75.           while (item != T_EOF)
  76.               {
  77.               result = last_put (item, result);
  78.             item = va_arg (ap, Object);
  79.             }
  80.         va_end (ap);
  81.         return (result);
  82.     }
  83. /* APPEND -- concatenates two lists non-destructively LISP equivalent */
  84. Object append (Object list1, Object list2)
  85.   {
  86.     Object rlist1;
  87.     if (list1 == NULL)
  88.        return(list2);
  89.     else 
  90.     if (list2 == NULL)
  91.        return(list1);
  92.     else
  93.       {
  94.         rlist1 = reverse(list1);
  95.         while(rlist1 != NULL)
  96.           {
  97.             list2 = first_put(first(rlist1), list2);
  98.             rlist1 = but_first(rlist1);
  99.           }
  100.       }
  101.     return(list2);
  102.   }
  103.   /* NCONC -- concatenate two lists (destructive (!) LISP equivalent) */
  104.  Object nconc (Object list_1, Object list_2)
  105.    {
  106.     Object list;
  107.     if (list_1 == NULL)
  108.        return (list_2);
  109.     else
  110.     if (list_2 == NULL)
  111.        return (list_1);
  112.     else
  113.       {
  114.         list = list_1;
  115.         while (but_first (list) != NULL)
  116.             list = but_first (list);
  117.         pair (list) -> cdr = list_2;
  118.         return (list_1);
  119.       }
  120.    }
  121.  /* LISP_UNION -- takes two lists and returns a new list containing everything 
  122.  that is an element of either of the lists (LISP 'UNION' Predicate)  */
  123.  Object lisp_union (Object list1, Object list2) 
  124.   {
  125.     return (remove_duplicates (append (list1, list2)));
  126.   }
  127. /* GET_PROP -- 'get' the property associated with 'indicator' on symbol */
  128. Object get_prop (Object sym, char *str)
  129.   {
  130.     Object prop_list, ind_list;
  131.     Object indic2 = make_string(str);            
  132.           prop_list = symbol(sym)->plist;
  133.       while (prop_list != NULL)
  134.         {
  135.           ind_list = first (prop_list);
  136.           prop_list = but_first (prop_list);
  137.           
  138.               if (strcmp (string (indic2), string (first (ind_list))) == 0)
  139.                 return (first (but_first (ind_list)));
  140.         }
  141.        return (NULL);
  142.   }
  143. /* PUT_PROP -- 'put' indicator-property on symbol's plist  */
  144. void put_prop (Object sym, char *str, Object property)
  145.   {
  146.     Object prop_list, ind_list, p2;
  147.     Object indic2 = make_string(str);
  148.       
  149.       /* add "structure-changed" bit if 'sym' marked for protection */
  150.       if(type(sym) > 7)
  151.           type(sym) = '\140' | ntype(sym);
  152.       prop_list = symbol(sym)->plist;
  153.       free_structure(prop_list);
  154.       if (prop_list != NULL)
  155.         {
  156.           p2 = NULL;
  157.           while (prop_list != NULL)
  158.             {
  159.               ind_list = first (prop_list);
  160.               prop_list = but_first(prop_list);
  161.               
  162.               if (strcmp (string (indic2), string (first (ind_list))) != 0)
  163.                       p2 = first_put(ind_list, p2);
  164.               else  /* remove protect bit for ind_list prop dat for g.c. */
  165.                 free_structure(ind_list);
  166.             }
  167.           p2 = first_put (list (indic2, property, T_EOF), p2);
  168.           symbol(sym)->plist = p2;
  169.          }
  170.        else
  171.           symbol(sym)->plist = first_put(list (indic2, property, T_EOF), prop_list);
  172.   }
  173. /* FREE_STRUCTURE -- recursively removes protection bit to free list structure
  174.                 for garbage collection. Protected symbols remain protected. */
  175. void free_structure (Object obj)
  176.   {
  177.     if(obj == NULL || type(obj) <= 7 || ntype(obj) == SYMBOL)
  178.         return;
  179.      else
  180.         switch (ntype(obj))
  181.           {
  182.             case SYMBOL:
  183.                return;
  184.             case STRING:
  185.             case INTEGER:
  186.             case FUNCTION:
  187.                  break;
  188.             case PAIR:
  189.                 type(obj) = ntype(obj); /* remove protect bit */
  190.                 free_structure (first(obj));
  191.                 free_structure (but_first(obj));
  192.                 break;
  193.                 default:
  194.                     error ("free_structure: not standard object");
  195.                     break;
  196.            }
  197.       type(obj) = ntype(obj);
  198.   }
  199. /* REMPROP -- 'remove' indicator-property from symbol's plist  */
  200. void remprop (Object sym, char *str)
  201.   {
  202.     Object foof, foo;
  203.     Object plist = symbol(sym)->plist;
  204.     Object indic = make_string(str);
  205.  /* add "structure-changed" bit if 'sym' marked for protection */
  206.     if(type(sym) > 7)
  207.         type(sym) = '\140' | ntype(sym);
  208.       free_structure(plist);
  209.           foo = NULL;
  210.       while(plist != NULL)
  211.          {
  212.          foof = first(plist);
  213.           plist = but_first(plist);
  214.           if(strcmp(string(indic), string(first(foof))) != 0)
  215.                         foo = first_put(foof, foo);
  216.                         else
  217.               free_structure(foof);
  218.               /* remove protect bit from ind_list prop data for g.c.  */
  219.          }
  220.        symbol(sym)->plist = foo;
  221.          }
  222. /* Lisp Variable for Gensym Symbols */
  223. int gensym_number = 0;  
  224. /* GENSYM -- make new interred lisp symbol.  Add one to global gensym counter */  
  225. Object gensym (char *ppp)
  226.   {
  227.       Object fname;
  228.       char sname[32];
  229.       gensym_number += 1;
  230.       sprintf(sname, "%s-%d", ppp, gensym_number);
  231.       fname = make_symbol(sname);
  232.       symbol(fname)->value = NULL;
  233.       return(fname);
  234.   }
  235. /* MAKE_INDIC  make-indicator for get_prop and put_prop functions */
  236. Object make_indic (char *str)
  237.   {
  238.       return (make_string (str));
  239.   }
  240. /* MAKE_PROP  symbol for get_prop and put_prop functions  */
  241. Object make_prop (char *str)
  242.   {
  243.       return (make_symbol (str));
  244.   }
  245. /********************************************************/
  246. /** LISP List Modifiers **/
  247. /* REVERSE -- return a new list in reverse order (LISP equivalent) */
  248. Object reverse (Object list1)
  249.     {
  250.     Object new_list = NULL;
  251.     while (list1 != NULL)
  252.         {
  253.         new_list = first_put (first (list1), new_list);
  254.         list1 = but_first (list1);
  255.         }
  256.     return (new_list);
  257.     }
  258. /* FLATTEN -- return the leaves of a tree (atoms of nested lists) */
  259. Object flatten (Object obj)
  260.   {
  261.   if (is_null (obj))
  262.       return (first_put (NULL, NULL));
  263.   else if (is_atom (obj))
  264.       return (list (obj, NULL));
  265.   else if (is_null (but_first (obj)))
  266.       return (flatten (first (obj)));
  267.   else
  268.       return (append (flatten (first (obj)), flatten (but_first (obj)) ));
  269.   }
  270. /* FLATTEN_NO_NILS -- 'flatten' a tree, discarding NULL atoms */
  271. Object flatten_no_nils (Object obj)
  272.   {
  273.       if (is_null (obj))
  274.           return (NULL);
  275.       else if (is_atom (obj))
  276.           return (list (obj, NULL));
  277.       else
  278.           return (append (flatten_no_nils (first (obj)),
  279.                           flatten_no_nils (but_first (obj)) ));
  280.   }
  281. /*****************************************************/
  282. /** LISP MAPPING FUNCTIONS: MAPC, MAPCAR  **/
  283. /* MAPC -- apply a function 'f' to each element of a list */
  284. void mapc (Function_1 f, Object list)
  285.   {
  286.       while (list != NULL)
  287.           {
  288.           (*f)(first (list));
  289.           list = but_first (list);
  290.           }
  291.    }
  292. /* MAPCAR -- apply a function 'f' to each element of a list, put results in list */
  293. Object mapcar (Function_1 f, Object list)
  294.   {
  295.       Object output = NULL;
  296.       while (list != NULL)
  297.         {
  298.             output = first_put ((*f) (first (list)), output);
  299.             list = but_first (list);
  300.         }
  301.        return (reverse (output));
  302.   }
  303. /* MAPL -- apply a function 'f' to successive 'cdr's' of a list  */
  304. void mapl (Function_1 f, Object arg_list)
  305.   {
  306.       while (arg_list != NULL)
  307.         {
  308.             (*f)(arg_list);
  309.             arg_list = but_first(arg_list);
  310.         }
  311.   }
  312. /* MAP_NO_NILS -- like 'mapc', but collect only non-NULL results */
  313. Object map_no_nils (Function_1 f, Object list)
  314.   {
  315.       Object result;
  316.       Object output;
  317.       output = NULL;
  318.       while (list != NULL)
  319.         {
  320.             result = (*f)(first (list));
  321.             if (result != NULL)
  322.                 output = first_put (result, output);
  323.             list = but_first (list);
  324.         }
  325.       return (reverse (output));
  326.   }
  327. /*****************************************************/
  328. /** LISP List Selectors **/
  329. /* NTH -- return nth element of a list or NULL (LISP equivalent) */
  330. Object nth (Object list, int n)
  331.   {
  332.       while ((list != NULL) && (n > 0))
  333.         {
  334.             list = but_first (list);
  335.             n--;
  336.         }
  337.       if (list != NULL)
  338.           return (first (list));
  339.       else
  340.           return (NULL);
  341.   }
  342. /* ASSOC -- association-list lookup returns PAIR whose 'first' matches key */
  343. Object assoc (Object key, Object a_list)
  344.   {
  345.       Object pair;
  346.       while (a_list != NULL)
  347.         {
  348.             pair = first (a_list);
  349.             if (first (pair) == key)
  350.                 return (pair);
  351.             else
  352.                 a_list = but_first (a_list);
  353.         }
  354.        return (NULL);
  355.   }
  356. /* pop_f -- pop an object off of a (list-based) stack: 'pop' macro helper */
  357. Object pop_f (Object *location)
  358.   {
  359.       Object item;
  360.       item = first (*location);
  361.       *location = but_first (*location);
  362.       return (item);
  363.   }
  364. /****************************************************/
  365. /** LISP LIST PROPERTIES  **/
  366. /* LENGTH -- return the integer length of a list (LISP equivalent) */
  367. int length (Object list)
  368.   {
  369.       int n;
  370.       n = 0;
  371.       while (list != NULL)
  372.         {
  373.             list = but_first (list);
  374.             n++;
  375.         }
  376.        return (n);
  377.   }
  378. /* IS_MEMBER -- T if 'obj' is identical to element of 'list', else NULL  */
  379. Object is_member (Object obj, Object list)
  380.   {      while (list != NULL)
  381.         {
  382.             if (lisp_equal((first (list)), obj))
  383.                 return (T);
  384.             else
  385.                 list = but_first (list);
  386.         }
  387.        return (NULL);  }/* MEMBER -- if 'obj' is identical to an element of 'list', return list from               that element in list, else return NULL (LISP EQUAL equivalent).   */Object member (Object obj, Object list)  {      while (list != NULL)        {            if (lisp_equal((first(list)), obj))                    return (list);            else                list = but_first (list);        }      return (NULL);  }/* LISP_EQUAL -- returns T iff Obj1 is 'equal in LISP sense' to Obj2,                   else return NULL    */Object lisp_equal (Object obj1, Object obj2)  {      if((is_atom (obj1)) && (is_atom (obj2)))        {            if(obj1 == obj2)                return(T);                            else if(ntype(obj1) == ntype(obj2) &&                    ntype(obj1) == INTEGER  &&                    integer(obj1) == integer(obj2))                return(T);                else              return (NULL);        }      else if ((is_atom (obj1)) && (is_list (obj2)))          return (NULL);      else if ((is_list (obj1)) && (is_atom (obj2)))          return (NULL);      else         {            if(lisp_equal((first (obj1)),(first(obj2))) &&               lisp_equal((but_first(obj1)),(but_first(obj2))))                return(T);            else                return(NULL);        }  }/* INDEX -- return index of first occurence of 'element' in 'list' */int index (Object element, Object list)  {      int n;      n = 0;      while ((list != NULL) && (first (list) != element))        {            list = but_first (list);            n++;        }      if (list != NULL)          return (n);      else          return (-1);  } /* SET_DIFFERENCE -- returns a list of elements in 'list1' that do not                      appear in 'list2'  */     Object set_difference (Object list1, Object list2)  {      Object sdl = NULL;            if(list2 == NULL || list1 == NULL)          return (reverse (list1));    while (list1 != NULL)     {        if(is_member ((first(list1)), list2))              list1 = but_first (list1);                          else             {                               sdl = first_put ((first (list1)), sdl);                list1 = but_first (list1);            }      }    return(sdl);  }/* INTERSECTION -- returns list of elements common to both lst1 and lst2  */Object intersection (Object lst1, Object lst2)  {      Object common = NULL;      if(!is_list(lst1) || !is_list(lst2))          error("\nintersection: arg not a list");            if(is_null(lst1) || is_null(lst2))          return(NULL);          else      {          while(lst1 != NULL)            {                if(is_member(first(lst1), lst2))                    common = first_put(first(lst1), common);                else                    ;                lst1 = but_first(lst1);            }      }    return(common);  }/* REMOVE_DUPLICATES -- remove duplicate lisp structures in list                         (uses LISP EQUAL) */Object remove_duplicates (Object obj)  {      Object nodups = NULL;            while (obj != NULL)        {            if (is_member (first(obj), but_first(obj)))                obj = but_first(obj);            else              {                nodups = first_put(first(obj), nodups);                obj = but_first(obj);              }         }       return(nodups);  }/* REMOVE_ITEM -- remove 'item' from 'sequence' list                   (LISP "REMOVE" predicate)  */Object remove_item (Object item, Object sequence)  {      Object pp, nitem = NULL;            if(lisp_equal(item, sequence))          return(NULL);      while(sequence != NULL)        {            pp = first(sequence);            sequence = but_first(sequence);                        if(lisp_equal(item, pp) )                ;            else                nitem = first_put(pp, nitem);                }       return(reverse(nitem));  }                             /*******************************************************//**  LISP OBJECT CONSTRUCTORS  **//* MAKE_C_STRING -- return a new copy of argument string in free memory */char *make_c_string (char *str)  {      char *new_string;      new_string = (char *) safe_malloc (strlen (str) + 1);      strcpy (new_string, str);      return (new_string);  }/* MAKE_SYMBOL -- return a new symbol of given name (no table lookup) */Object make_symbol (char *name)  {      Object new_symbol;      new_symbol = (Object) safe_malloc (sizeof (Object_Type) +                                  sizeof (Symbol_Entry) );            type (new_symbol) = SYMBOL;      symbol (new_symbol) -> print_name = make_c_string (name);      symbol (new_symbol) -> value = _UNDEFINED;      symbol (new_symbol) -> plist = NULL;      return (new_symbol);  }/* MAKE_STRING -- return a new STRING Object with value of given string */Object make_string (char *s)  {      Object new_string;      new_string = (Object) safe_malloc (sizeof (Object_Type) + strlen (s) + 1);      type (new_string) = STRING;      strcpy (string (new_string), s);      return (new_string);   }/* MAKE_INTEGER -- return a new INTEGER Object of specified value */Object make_integer (int n)  {      Object new_integer;      new_integer = (Object) safe_malloc (sizeof (Object_Type) + sizeof (int) );      type (new_integer) = INTEGER;      integer (new_integer) = n;      return (new_integer);  }/* MAKE_FUNCTION -- return a new FUNCTION Object of specified value */Object make_function (Function f)  {      Object new_function;      new_function = (Object) safe_malloc (sizeof (Object_Type) +                                           sizeof (Function) );      type(new_function) = FUNCTION;      function (new_function) = f;      return (new_function);  }/************************************************************//** Symbolic Output  **//* WRITE_SPACES -- write 'n' spaces to 'stdout' */void write_spaces (int n)  {      int i;      for (i = 0; i < n; i++)          putchar (SPACE);  }/* write_c_string -- write standard C string with double-quotes and escapes */void write_c_string (char *s)  {      putchar (DOUBLE_QUOTE);      while (*s != EOS)        {            switch (*s)              {                  case NEWLINE:                    putchar (BACKSLASH);                    putchar ('n');                    break;                  case TAB:                    putchar (BACKSLASH);                    putchar ('t');                    break;                  case FORMFEED:                    putchar (BACKSLASH);                    putchar ('f');                    break;                  case BACKSLASH:                    putchar (BACKSLASH);                    putchar (BACKSLASH);                    break;                  case DOUBLE_QUOTE:                    putchar (BACKSLASH);                    putchar (DOUBLE_QUOTE);                    break;                  default:                    putchar (*s);                    break;             }            s++;        }        putchar (DOUBLE_QUOTE); }/* WRITE_SYMBOL -- write printed representation of SYMBOL Object */void write_symbol (Object obj)  {      if(type(obj) > 7)          printf("%s", string(get_prop(obj, "pn")));      else          printf ("%s", symbol(obj) -> print_name);  }  /* write_string -- write printed representation of STRING Object */void write_string (Object obj)  {      write_c_string (string (obj));  }/* pp_object -- pretty-print an Object starting at 'col', output at 'hpos' */void pp_object (Object obj, int col, int hpos)  {      int i;      write_spaces (col - hpos);      hpos = col;      if (obj == NULL)          printf ("()");      else          switch (ntype (obj))            {                case SYMBOL:                    write_symbol (obj);                    break;                case STRING:                    write_string (obj);                    break;                case INTEGER:                    printf ("%d", integer (obj));                    break;                case PAIR:                /* for now, assume proper list (ending in NULL 'but_first')  */                    putchar (LEFT_PAREN);                    hpos++;                    while (obj != NULL)                      {                          if (! is_pair (obj))                              error ("pp_object: not proper list");                          pp_object (first (obj), col+1, hpos);                          obj = but_first (obj);                          if (obj != NULL)                            {                                hpos = 0;                            }                      }                     putchar (RIGHT_PAREN);                     break;                case FUNCTION:                    printf ("#<function>");                    break;                default:                    error ("pp_object: not standard object");                    break;           }      }   /*  write_object -- write (re-readable) printed representation of Object */ void write_object (Object obj)   {       pp_object (obj, 1, 0);     /* indent 1 space before printing  */   }   tring(get_prop(obj, "pn")));      else          printf ("%s", symbol(obj) -> print_name);  }  /* write_string -- write printed representation of STRING Object */void write_string (Object obj)  {      write_c_string (string (obj));  }
  388. /* pp_object²
  389.